home *** CD-ROM | disk | FTP | other *** search
/ Young Minds / Young Minds Interactive CD-ROM.ISO / monster / guts.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-12-01  |  9.5 KB  |  351 lines
  1. [inherit ('sys$library:starlet')]
  2.  
  3. module guts(input,output);
  4.  
  5. const
  6.         SHORT_WAIT = 0.1;
  7.         LONG_WAIT = 0.2;
  8.         maxcycle = 15;          { attempting to fine tune nextkey }
  9.  
  10. type
  11.         $uword = [word] 0 .. 65535;
  12.         string = varying[80] of char;
  13.         ident = packed array[1..12] of char;
  14.  
  15.         iosb_type = record
  16.                 cond: $uword;
  17.                 trans: $uword;
  18.                 junk: unsigned; {longword}
  19.         end;
  20.  
  21.         il3 = record
  22.              buflen : $uword;
  23.              itm    : $uword;
  24.              baddr  : unsigned;
  25.              laddr  : unsigned;
  26.         end;
  27.  
  28.  
  29. var
  30.         pbrd_id:        unsigned;       { pasteboard id    }
  31.         kbrd_id:        unsigned;
  32.         pbrd_volatile:  [volatile] unsigned;
  33.         mbx:            [volatile] packed array[1..132] of char;
  34.         mbx_in,                                 { channels for input and   }
  35.         mbx_out:        [volatile] $uword;      { output to the subprocess }
  36.         pid:            integer;
  37.         iosb:           [volatile] iosb_type;   { i/o status block         }
  38.         status:         [volatile] unsigned;
  39.         save_dcl_ctrl:  unsigned;
  40.         trap_flag:      [global,volatile] boolean;
  41.         trap_msg:       [global,volatile] string;
  42.         out_chan:       $uword;
  43.         vaxid:          [global] packed array[1..12] of char;
  44.         advise:         [external] string;
  45.         line:           [global] string;
  46.         old_prompt: [global] string;
  47.  
  48.         seed: integer;
  49.  
  50.         user,uname:varying[31] of char;
  51.         sts:integer;
  52.         il:array[1..2] of il3;
  53.         key:$uword;
  54.  
  55.         userident: [global] ident;
  56.  
  57.  
  58. [asynchronous, external (lib$signal)]
  59. function lib$signal (
  60.    %ref status : [unsafe] unsigned) : unsigned; external;
  61.  
  62. [asynchronous, external (str$trim)]
  63. function str$trim (
  64.    destination_string : [class_s] packed array [$l1..$u1:integer] of char;
  65.    source_string : [class_s] packed array [$l2..$u2:integer] of char;
  66.    %ref resultant_length : $uword) : unsigned; external;
  67.  
  68. [asynchronous, external (smg$read_keystroke)]
  69. function smg$read_keystroke (
  70.     %ref keyboard_id : unsigned;
  71.     %ref word_integer_terminator_code : $uword;
  72.     prompt_string : [class_s] packed array [$l3..$u3:integer] of char := %immed
  73. 0;
  74.     %ref timeout : unsigned := %immed 0;
  75.     %ref display_id : unsigned := %immed 0;
  76.     %ref rendition_set : unsigned := %immed 0;
  77.     %ref rendition_complement : unsigned := %immed 0) : unsigned; external;
  78.  
  79. [asynchronous, external (smg$create_virtual_keyboard)]
  80. function smg$create_virtual_keyboard (
  81.     %ref keyboard_id : unsigned;
  82.     filespec : [class_s] packed array [$l2..$u2:integer] of char := %immed 0;
  83.     default_filespec : [class_s] packed array [$l3..$u3:integer] of char := %immed 0;
  84.     resultant_filespec : [class_s]
  85.     packed array [$l4..$u4:integer] of char := %immed 0) : unsigned; external;
  86.  
  87. [asynchronous, external (lib$disable_ctrl)]
  88. function lib$disable_ctrl (
  89.     %ref disable_mask : unsigned;
  90.     %ref old_mask : unsigned := %immed 0) : unsigned; external;
  91.  
  92. [asynchronous, external (lib$enable_ctrl)]
  93. function lib$enable_ctrl (
  94.     %ref enable_mask : unsigned;
  95.     %ref old_mask : unsigned := %immed 0) : unsigned; external;
  96.  
  97.  
  98. procedure syscall( s: [unsafe] unsigned );
  99.  
  100. begin
  101.    if not odd( s ) then begin
  102.       lib$signal( s );
  103.    end;
  104. end;
  105.  
  106.  
  107. [external,asynchronous]
  108. function mth$random(var seed: integer): real;
  109. external;
  110.  
  111. [global]
  112. function random: real;
  113.  
  114. begin
  115.         random := mth$random(seed);
  116. end;
  117.  
  118. [global]
  119. function rnd100: integer;       { random int between 0 & 100, maybe }
  120.  
  121. begin
  122.         rnd100 := round(mth$random(seed)*100);
  123. end;
  124.  
  125.  
  126. [external] function lib$wait(seconds:[reference] real):integer;
  127. external;
  128.  
  129. [global]
  130. procedure wait(seconds: real);
  131.  
  132. begin
  133.         syscall( lib$wait(seconds) );
  134. end;
  135.  
  136. [external] procedure checkevents(silent: boolean := false);
  137. extern;
  138.  
  139.  
  140. [global]
  141. procedure doawait(time: real);
  142.  
  143. begin
  144.         syscall( lib$wait(time) );
  145. end;
  146.  
  147.  
  148. [global]
  149. function trim(s: string): string;
  150. var
  151.         tmp: [static] string := '';
  152.  
  153. begin
  154.         syscall( str$trim(tmp.body,s,tmp.length) );
  155.         trim := tmp;
  156. end;
  157.  
  158.  
  159. [global]
  160. function get_userid: string;
  161.  
  162. begin
  163.   il:=zero;
  164.   il[1].itm    := jpi$_username;
  165.   il[1].buflen := size(user.body);
  166.   il[1].baddr  := iaddress(user.body);
  167.   il[1].laddr  := iaddress(user.length);
  168.   syscall($getjpiw(,,,il));
  169.   syscall( str$trim(uname.body,user,uname.length) );
  170.   userident := user;
  171.   get_userid := uname;
  172. end;
  173.  
  174.  
  175. [global]
  176. procedure putchars(s: string);
  177. var
  178.         msg: packed array[1..128] of char;
  179.         len: integer;
  180.  
  181. begin
  182.         msg := s;
  183.         len := length(s);
  184.         syscall($qiow(,out_chan,io$_writevblk,,,,msg,len,,,,));
  185. end;
  186.  
  187. [global]
  188. function keyget: char;
  189. var
  190.         term: [static] $uword := 0;
  191.         i: integer;
  192.  
  193. begin
  194.         if (smg$read_keystroke(kbrd_id,term,,0,,,) mod 2) = 0 then
  195.                 keyget := chr(0)
  196.         else begin
  197.                 i := term;
  198.                 keyget := chr(i);
  199.         end;
  200. end;
  201.  
  202. [global] function firstkey:char;
  203. var
  204.         ch: char;
  205.  
  206. begin
  207.         ch := keyget;
  208.         if ch = chr(0) then begin
  209.                 repeat
  210.                         checkevents;
  211.                         doawait(LONG_WAIT);
  212.                         ch := keyget;
  213.                 until ch <> chr(0);
  214.         end;
  215.         firstkey := ch;
  216. end;
  217.  
  218. [global] function nextkey:char;
  219. var
  220.         ch: char;
  221.         cycle: integer;
  222.  
  223. begin
  224.         cycle := 0;
  225.         ch := keyget;
  226.         if ch = chr(0) then begin
  227.                 repeat
  228.                         if cycle = maxcycle then begin
  229.                                 checkevents;
  230.                                 doawait(SHORT_WAIT);
  231.                                 cycle := 0;
  232.                         end;
  233.                         cycle := cycle + 1;
  234.  
  235.         { should doawait(SHORT_WAIT) be in the cycle check, or should
  236.           it be only in the repeat loop (done every repeat) ?
  237.           When the system gets slow, character input gets VERY slow.
  238.           Is this because of the checkevents, the wait, or is it
  239.           just a symptom of a slow VAX? }
  240.  
  241.                         ch := keyget;
  242.                 until ch <> chr(0);
  243.         end;
  244.         nextkey := ch;
  245. end;
  246.  
  247.  
  248. [global]
  249. procedure grab_line(prompt:string; var s:string;echo:boolean := true);
  250. var
  251.         ch: char;
  252.         pos: integer;
  253.         i: integer;
  254.  
  255. begin
  256.         old_prompt := prompt;
  257.         putchars(chr(10)+prompt);
  258.         line := '';
  259.         ch := firstkey;
  260.         while (ch <> chr(13)) do begin
  261. { del char }    if (ch = chr(8)) or (ch = chr(127)) then begin
  262.                         case length(line) of
  263.                                 0: ch := firstkey;
  264.                                 1:begin
  265.                                         line := '';
  266.                                         if echo then
  267.                                                 putchars(chr(8)+' '+chr(8));
  268.                                         ch := nextkey;
  269.                                   end;
  270.                                 2:begin
  271.                                         line := line[1];
  272.                                         if echo then
  273.                                                 putchars(chr(8)+' '+chr(8));
  274.                                         ch := nextkey;
  275.                                   end;
  276.                                 otherwise begin
  277.                                         line := substr(line,1,length(line)-1);
  278.                                         if echo then
  279.                                                 putchars(chr(8)+' '+chr(8));
  280.                                         ch := nextkey;
  281.                                 end;
  282.                         end;    { CASE }
  283. { cancel line } end { if } else if ch = chr(21) then begin
  284.                         putchars(chr(13)+chr(27)+'[K');
  285. {                       pos := length(prompt) + length(line);
  286.                         if pos > 0 then
  287.                                 for i := 1 to pos do
  288.                                         putchars(chr(8)+' '+chr(8));    }
  289.                         putchars(prompt);
  290.                         line := '';
  291.                         ch := firstkey;
  292. {line too long} end else if length(line) > 76 then begin
  293.                         putchars(chr(7));
  294.                         ch := nextkey;
  295. { no ctrls }    end else if ord(ch) > 31 then begin
  296.                         line := line + ch;
  297.                         if echo then
  298.                                 putchars(ch);
  299.                         ch := nextkey;
  300.                 end else
  301.                         ch := nextkey;
  302. { ***           ch := nextkey;           *** }
  303.         end;    { WHILE }
  304.         pos := length(prompt) + length(line);
  305.  
  306. {       if pos > 0 then
  307.                 for i := 1 to pos do
  308.                         putchars(chr(8));       }
  309.  
  310.         putchars(chr(13));
  311.  
  312.         s := line;
  313. end;
  314.  
  315.  
  316. [global]
  317. procedure setup_guts;
  318. var
  319.         border: unsigned;
  320.         rows,cols: integer;
  321.         mask: unsigned;
  322.  
  323. begin
  324.         seed := clock;
  325.         old_prompt := '';
  326.  
  327. {   border := 1;
  328.    smg$create_pasteboard(pbrd_id,,rows,cols,border);    }
  329.  
  330.    smg$create_virtual_keyboard(kbrd_id);
  331.    pbrd_volatile := pbrd_id;
  332.  
  333.    syscall($assign('SYS$OUTPUT',out_chan));
  334.  
  335.    mask := %X'02000000';        { CTRL/Y  Just for DCL }
  336. { mask := ...21... for ctrl-t too }
  337.    syscall( lib$disable_ctrl( mask, save_dcl_ctrl ));
  338.  
  339.    mask := %X'02000008';        { nuke CTRL/Y & CTRL/C completely }
  340. {   syscall( smg$set_out_of_band_asts(pbrd_id,mask,trapper)); }
  341. end;
  342.  
  343. [global]
  344. procedure finish_guts;
  345.  
  346. begin
  347.         syscall( lib$enable_ctrl(save_dcl_ctrl));       { re-enable dcl ctrls }
  348. end;
  349.  
  350. end.
  351.